home *** CD-ROM | disk | FTP | other *** search
/ Just Call Me Internet / Just Call Me Internet.iso / prog / atari / m2 / cat3src / magic / i / xbra.i < prev   
Text File  |  1997-10-26  |  9KB  |  292 lines
  1. (*----------------------------------------------------------------------*
  2.  *                                                                      *
  3.  *         MAGIC   Modula's  All purpose  GEM  Interface  Cadre         *
  4.  *                 ÿ         ÿ            ÿ    ÿ          ÿ             *
  5.  *----------------------------------------------------------------------*
  6.  * Version 3.30  02.02.1992     (C)90/91/92 by Peter Hellinger Software *
  7.  *----------------------------------------------------------------------*
  8.  *            Dieses Modul ist urheberrechtlich geschtzt.              *
  9.  *                                                                      *
  10.  * Die Ver”ffentlichung des Quelltextes oder Teilen daraus in schrift-  *
  11.  * licher Form, insbesondere in Zeitschriften, sowie die Verbreitung    *
  12.  * ber Public-Domain-H„ndler bedarf der ausdrcklichen schriftlichen   *
  13.  * Genehmigung des Autors!                                              *
  14.  *                                                                      *
  15.  * Der Autor gibt hiermit die ausdrckliche Erlaubnis, das Modul jeder- *
  16.  * zeit auch im Quelltext weiterzugegeben, sofern dessen Text und ins-  *
  17.  * besondere dieser Urheberrechts-Vermerk nicht ver„ndert wird, und     *
  18.  * durch die Weitergabe kein finanzieller Nutzen entsteht. Der Autor    *
  19.  * beh„lt sich das Recht vor, diese Erlaubnis jederzeit u. ohne Angaben *
  20.  * von Grnden zu widerrufen.                                           *
  21.  *----------------------------------------------------------------------*)
  22.  
  23. IMPLEMENTATION MODULE XBRA;
  24.  
  25.  
  26.  
  27. (* IMPLEMENTATION FšR  >>> Megamax-Modula-2 <<< *)
  28. (*                                              *)
  29. (*$R-   Range-Checks                            *)
  30. (*$S-   Stack-Check                             *)
  31. (*                                              *)
  32. (*----------------------------------------------*)
  33.  
  34.  
  35.  
  36.  
  37.  
  38.  
  39. (*
  40.   18.06.89 Thomas Tempelmann:   Megamax-Version
  41.   04.07.89 Peter Hellinger:     Umgearbeitet auf TDI
  42.   05.05.91 Peter Hellinger:     Modul arbeitet jetzt unabh„ngig vom 
  43.                                 verwendeten Compiler (MM2, TDI, SPC, LPR)
  44. *)
  45.  
  46. IMPORT SYSTEM;
  47. FROM MagicSys IMPORT CastToAddr, lWORD, sCARDINAL;
  48. FROM MagicDOS IMPORT Super;
  49.  
  50.  
  51. CONST   JmpInstr = 4EF9H; (* Code fr 'JMP <adr>.L' *)
  52.  
  53.  
  54.  MODULE SysUtil1;
  55.   
  56.  (*
  57.   * lokales Modul mit Funktionen zum Zugriff auf Daten im Supervisor-Modus
  58.   * ----------------------------------------------------------------------
  59.   *
  60.   * Die in diesem Modul verwendeten Funktionen
  61.   *   SuperPeek, SuperLPeek und SuperLPoke
  62.   * dienen dazu, Daten im Supervisor-Mode zuzuweisen. Sie sind folgender-
  63.   * mažen definiert:
  64.   *   PROCEDURE SuperPeek  ( addr: ADDRESS; VAR data: ARRAY OF BYTE );
  65.   *     liest ab der Adresse 'addr' die Anzahl von 'HIGH (data)+1' Bytes.
  66.   *   PROCEDURE SuperLPeek ( addr: ADDRESS ): LONGWORD;
  67.   *     liefert 4 Bytes ab Adresse 'addr'.
  68.   *   PROCEDURE SuperLPoke ( addr: ADDRESS; data: LONGWORD );
  69.   *     weist 4 Bytes ab Adresse 'addr' zu.
  70.   * Diese Funktionen mssen auch korrekt ablaufen, wenn bereits bei ihrem
  71.   * Aufruf der Supervisor-Mode aktiv ist. Sie k”nnen wahlweise durch Verwen-
  72.   * dung der Funktion 'XBIOS.SuperExec' ('sup_exec()') oder mit 'GEMDOS.Super'
  73.   * ('super()') implementiert werden.
  74.   *)
  75.   
  76.   IMPORT SYSTEM, CastToAddr, sCARDINAL, lWORD, Super;
  77.   
  78.   EXPORT SuperPeek, SuperLPeek, SuperLPoke;
  79.   
  80.   VAR   from, to: POINTER TO SYSTEM.BYTE;
  81.         bytes:    sCARDINAL;
  82.         stack:    SYSTEM.ADDRESS;
  83.   
  84.   PROCEDURE set;
  85.   VAR one: sCARDINAL;
  86.   BEGIN
  87.    one:= 1;
  88.    
  89.    
  90.    
  91.     stack:= LONG (0); 
  92.    Super (stack);
  93.    WHILE bytes > 0 DO
  94.     to^:= from^;  
  95.     to:= CastToAddr (to) + CastToAddr (one);
  96.     from:= CastToAddr (from) + CastToAddr (one);
  97.     DEC (bytes)
  98.    END;
  99.    Super (stack);
  100.   END set;
  101.   
  102.   PROCEDURE SuperPeek  (addr: SYSTEM.ADDRESS; VAR data: ARRAY OF SYSTEM.BYTE);
  103.   BEGIN
  104.    from:= addr;
  105.    to:= SYSTEM.ADR (data);
  106.    bytes:= HIGH (data) + 1;
  107.    set; (* 'set' im Supervisor-Mode ausfhren *)
  108.   END SuperPeek;
  109.   
  110.   PROCEDURE SuperLPeek ( addr: SYSTEM.ADDRESS ): lWORD;
  111.   VAR data: lWORD;
  112.   BEGIN
  113.    from:= addr;
  114.    to:= SYSTEM.ADR (data);
  115.    bytes:= 4;
  116.    set; (* 'set' im Supervisor-Mode ausfhren *)
  117.    RETURN data
  118.   END SuperLPeek;
  119.   
  120.   PROCEDURE SuperLPoke ( addr: SYSTEM.ADDRESS; data: lWORD );
  121.   BEGIN
  122.    from:= SYSTEM.ADR (data);
  123.    to:= addr;
  124.    bytes:= 4;
  125.    set; (* 'set' im Supervisor-Mode ausfhren *)
  126.   END SuperLPoke;
  127.   
  128.  END SysUtil1; (* lokales Modul *)
  129.  
  130.  
  131. CONST   Magic =         'XBRA';
  132.         entryOffs =     12; (* Differenz zw. 'Carrier.magic' und 'Carrier.entry' *)
  133.  
  134.  (*
  135.   * Hilfsfunktionen, die ggf. optimiert werden k”nnen
  136.   * -------------------------------------------------
  137.   *)
  138.  
  139. PROCEDURE equal (s1, s2: ID): BOOLEAN;
  140. VAR p1, p2: POINTER TO SYSTEM.ADDRESS; (* ein 4-Byte-Datentyp *)
  141. BEGIN
  142.  p1:= SYSTEM.ADR (s1);
  143.  p2:= SYSTEM.ADR (s2);
  144.  RETURN p1^ = p2^
  145. END equal;
  146.  
  147. PROCEDURE sub (p: SYSTEM.ADDRESS; n: sCARDINAL): SYSTEM.ADDRESS;
  148. BEGIN
  149.  RETURN p - CastToAddr (n)
  150. END sub;
  151.  
  152.  (*
  153.   * Exportierte Funktionen
  154.   * ----------------------
  155.   *)
  156.  
  157. PROCEDURE Create (VAR use: Carrier; name: ID; call: SYSTEM.ADDRESS;
  158.                   VAR entry: SYSTEM.ADDRESS);
  159. BEGIN
  160.  use.name:= name;
  161.  use.magic:= Magic;
  162.  use.prev:= NIL;
  163.  use.entry.jmpInstr:= JmpInstr; (* Code fr 'JMP <adr>.L' *)
  164.  use.entry.operand:= call;
  165.  entry:= SYSTEM.ADR (use.entry)
  166. END Create;
  167.  
  168. PROCEDURE Installed (name: ID; vector: SYSTEM.ADDRESS; VAR at: SYSTEM.ADDRESS): BOOLEAN;
  169. VAR pc:    POINTER TO Carrier;
  170.     entry: SYSTEM.ADDRESS;
  171.     c:     Carrier;
  172.     lw:    lWORD;
  173. BEGIN
  174.  at:= vector; (* Vorwahl fr RETURN FALSE *)
  175.  LOOP
  176.   lw:= SuperLPeek (vector);
  177.   entry:= CastToAddr (lw);
  178.   IF entry = NIL THEN RETURN FALSE END;
  179.   pc:= sub (entry, entryOffs);
  180.   SuperPeek (pc, c);
  181.   IF equal (c.magic, Magic) THEN
  182.    (* XBRA-Kennung gefunden *)
  183.    IF equal (c.name, name) THEN  at:= vector;  RETURN TRUE;
  184.                            ELSE  vector:= sub (entry, 4);
  185.    END
  186.   ELSE
  187.    (* Ende, da XBRA-Kette zuende *)
  188.    RETURN FALSE
  189.   END;
  190.  END;
  191. END Installed;
  192.  
  193. PROCEDURE Install (entry: SYSTEM.ADDRESS; at: SYSTEM.ADDRESS);
  194. VAR pc: POINTER TO Carrier;
  195.     lw: lWORD;
  196. BEGIN
  197.  IF (entry = NIL) OR (at = NIL) THEN
  198.   HALT
  199.  ELSE
  200.   pc:= sub (entry, entryOffs);
  201.   lw:= SuperLPeek (at);
  202.   pc^.prev:= CastToAddr (lw);
  203.   SuperLPoke (at, entry)
  204.  END
  205. END Install;
  206.  
  207. PROCEDURE Remove (at: SYSTEM.ADDRESS);
  208. VAR pc:    POINTER TO Carrier;
  209.     entry: SYSTEM.ADDRESS;
  210.     c:     Carrier;
  211.     lw:    lWORD;
  212. BEGIN
  213.  IF at = NIL THEN
  214.   HALT
  215.  ELSE
  216.   entry:= SYSTEM.ADDRESS( SuperLPeek (at));
  217.   IF entry = NIL THEN
  218.    HALT
  219.   ELSE
  220.    pc:= sub (entry, entryOffs);
  221.    SuperPeek (pc, c);
  222.    IF equal (c.magic, Magic) THEN  SuperLPoke (at, c.prev);
  223.                              ELSE  HALT;
  224.    END
  225.   END
  226.  END
  227. END Remove;
  228.  
  229. PROCEDURE Query (vector: SYSTEM.ADDRESS; with: QueryProc);
  230. VAR pc:    POINTER TO Carrier;
  231.     entry: SYSTEM.ADDRESS;
  232.     c:     Carrier;
  233.     dummy: BOOLEAN;
  234.     lw:    lWORD;
  235. BEGIN
  236.  LOOP
  237.   lw:= SuperLPeek (vector);
  238.   entry:= CastToAddr (lw);
  239.   IF entry = NIL THEN RETURN END;
  240.   pc:= sub (entry, entryOffs);
  241.   SuperPeek (pc, c);
  242.   IF NOT equal (c.magic, Magic) THEN  EXIT  END;
  243.   IF NOT with (vector, c.name) THEN RETURN END;
  244.    (* Vorg„nger ist dran *)
  245.   vector:= sub (entry, 4)
  246.  END;
  247.  dummy:= with (vector, '????')
  248. END Query;
  249.  
  250. PROCEDURE Entry (at: SYSTEM.ADDRESS): SYSTEM.ADDRESS;
  251. VAR lw: lWORD;
  252. BEGIN
  253.  lw:= SuperLPeek (at);
  254.  RETURN CastToAddr (lw);
  255. END Entry;
  256.  
  257. PROCEDURE Called (at: SYSTEM.ADDRESS): SYSTEM.ADDRESS;
  258. VAR pc:    POINTER TO Carrier;
  259.     entry: SYSTEM.ADDRESS;
  260.     c:     Carrier;
  261.     lw:    lWORD;
  262. BEGIN
  263.  lw:= SuperLPeek (at);
  264.  entry:= CastToAddr (lw);
  265.  IF entry # NIL THEN
  266.   pc:= sub (entry, entryOffs);
  267.   SuperPeek (pc, c);
  268.   IF equal (c.magic, Magic) THEN
  269.    IF c.entry.jmpInstr = JmpInstr THEN
  270.     (* Wenn dies eine vom XBRA-Modul erzeugte Struktur ist, dann lie- *)
  271.     (* fern wir die Code-Adresse, die bei 'Install' angegeben wurde.  *)
  272.     RETURN c.entry.operand
  273.    END
  274.   END;
  275.   (* Ansonsten wird einfach die direkte Einsprungadr. geliefert *)
  276.   RETURN entry
  277.  END;
  278.  RETURN NIL
  279. END Called;
  280.  
  281. PROCEDURE PreviousEntry (entry: SYSTEM.ADDRESS): SYSTEM.ADDRESS;
  282. VAR pc: POINTER TO Carrier;
  283. BEGIN
  284.  IF entry # NIL THEN
  285.   pc:= sub (entry, entryOffs);
  286.   IF equal (pc^.magic, Magic) THEN  RETURN pc^.prev  END;
  287.  END;
  288.  RETURN NIL
  289. END PreviousEntry;
  290.  
  291. END XBRA.
  292.